perm filename PLTSRT.F4[NEW,LCS]6 blob
sn#163343 filedate 1975-06-09 generic text, type T, neo UTF8
00010 C SUBRS. SLUR, (JUGGLE), (LOOP), PLTSRT, (LINES), (HOMER),
00110 C (PLACE), (FINDIT), SCL, FORMAT
06300
06500 SUBROUTINE SLUR
06600 IMPLICIT INTEGER(A-Q,T-Z)
06610 COMMON/SLR/ SLURX(72)
06700 REAL CENTR,PWDS
06710 COMMON /XRN/RN(4000) /PLTR/PLT,RHT,RDIS
06900 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
06950 1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
06962 1 J5,J6,J7,J8,J9,J10,J11,JQ(9)
07000 COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(-3/4),RSJT2
07010 COMMON/ALF/INP,SLURY(72)
07400 CF DATA RZZ/2.8/
07500 C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
07600
07805 IF(JA.NE.12)GO TO 2
07810 CF RA=5.96*RSJT2*R5
07815 CF L=3
07817 CF J8=J8*RDIS
07820 CF IF(J7.LE.J6)J7=J7+360
07822 CF KQ=6
07823 CF IF(PLT)KQ=1
07825 CF10 DO 3 K=J6,J7,KQ
07830 CF R=K
07835 CF CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
07840 CF3 L=2
07841 CF J8=J8-1
07842 CF IF(J8)RETURN
07843 CF RA=RA+1/RDIS
07845 CF L=3
07847 CF GO TO 10
07848 CJA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
07849 CALL CIRCLE
07850 RETURN
07880
07900 2 J10=1
07901 J4=-1
07903 J5=3
07905 C ↑↑↑↑ FOR DPY ONLY (1/3 OF SEGS ARE USED)
07907 TWICE=-1
07930 21 RST7=RSJT2*7.
07960 RQQ=R5-R4
08000 IF(R6.GT.1000)CALL RNOTE(R6)
08010 GO TO (5,6,7),J8+4
08015 GO TO 4
08020 5 R=32
08025 C AFTER DOTTED NOTE
08030 GO TO 8
08040 6 R=22
08045 C BETWEEN NOTES
08050 8 RX=-1.3
08060 GO TO 9
08070 7 R=7
08080 RX=RSJT2
08090 9 CALL RJBX(R)
08100 R6=R6+RX
08250 4 RXX=RHORZ(R6)-R3
08260 RTILT=RQQ*RST7
08270 80 RX=SQRT(RXX**2+RTILT**2)
08272 IF(J8.NE.-1)GO TO 1
08274 IF(RQQ.GT.8)RQQ=8
08276 IF(RQQ.LT.-8)RQQ=-8
08277 RQQ=RQQ*RSTFAC(J2)*1.0
08278 IF(R7)RQQ=-RQQ
08279 R3=R3-RQQ
08280 C MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
08290 1 R=CENTR
08300 IF(J8.GT.0)GO TO 180
08310 L=72
08400 C FOR BRACKETS
08405 CALL SLOOP
08407
08410 CF RB=RX/71.
08500 CF DO 81 K=0,71
08600 CF81 SLURX(K+1)=RB*(K)+R3
08700 CF RA=R7*RST7
08775 CF41 IF(R9.EQ.0)R9=RZZ
08800 CF R=R+RA
08900 CF L=0
09000 CF DO 40 K=36,1,-1
09100 CF L=L+1
09200 CF RW=R-RA*(K/36.)**R9
09300 CF SLURY(L)=RW
09400 CF40 SLURY(73-L)=RW
09600 CF L=72
09700
09800 CF89 IF(RTILT.EQ.0)GO TO 87
10000 CF RW=ATAN2(RTILT,RXX)
10100 CF RA=SIN(RW)
10200 CF RB=COS(RW)
10300 CF RZ=SLURX(1)
10400 CF RW=SLURY(1)
10800 CF DO 83 K=1,L
10900 CF R=SLURX(K)-RZ
10950 CF RXX=SLURY(K)-RW
11000 CF SLURX(K)=RB*R-RA*RXX+RZ
11100 CF83 SLURY(K)=RB*RXX+RA*R+RW
11200
11300 87 IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
11310 CC J5=KQ
11320 J6=J10
11330 J7=L
11340 IF(J4.NE.0)GO TO 22
11350 CALL EXCH(J6,J7)
11360 J5=-1
11400 22 DO 88 K=J6,J7,J5
11500 88 CALL LINES(SLURX(K),SLURY(K),2)
11505 IF(J5.GT.1)CALL LINES(SLURX(72),SLURY(72),2)
11507 C DISPLAY END POINT OF SLUR
11510 IF(TWICE)RETURN
11520 TWICE=TWICE-1
11522 GO TO 182
11700 180 RW=R+R7*RST7
11710 TWICE=-1
11750 CC KQ=1
11752 J5=1
11800 RX=RX+R3
11900 CC RA=(R5-R4)*RST7
11910 IF(J9.EQ.0)GO TO 181
11911 RZ=RTILT/(RX-R3)
11912 TWICE=2
11913 CC RZ=RX-R3
11914 RXX=RX
11916 RWID=(R3+RXX)/2.
11992 182 IF(TWICE.EQ.1)GO TO 183
11993 C DOES LEFT SIDE FIRST.
11994 IF(TWICE.EQ.0)GO TO 184
11995 C LAST IS NUMBER.
11996 J8=2
11999 RC=RSJT2*13.
12000 RX=RWID-RC
12010 RWW=RTILT
12012 185 RTILT=RZ*(RX-R3)
12020
12030 C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
12040
12050 GO TO 181
12060 183 J8=3
12062 RX=RXX
12066 RTILT=RWW
12068 RXX=R3
12070 R3=RWID+RC
12082 RXX=RZ*(R3-RXX)
12100 R=R+RXX
12110 RW=RW+RXX
12120 GO TO 185
12150
12180 181 SLURX(1)=R3
12190 SLURY(1)=R
12200 SLURX(2)=R3
12300 SLURY(2)=RW
12400 SLURX(3)=RX
12500 SLURY(3)=RW+RTILT
12600 SLURX(4)=RX
12700 SLURY(4)=R+RTILT
12800 L=4
12900 IF(J8.EQ.2)L=3
13000 IF(J8.EQ.3)J10=2
13010 CC TWICE=-1
13100 GO TO 87
13110 184 J3=RWID
13120 C PUT IN VERT. POS. WHEN SLOPE!
13130 R4=RQQ/2.+R4+R7-1.
13135 R6=1.
13136 C R7=1 IS FOR ITALICS
13137 R7=1
13138 C OR USE 1 FOR ITALIC NUMBERS.
13139 R8=0
13140 CALL MAKNUM(R9)
13200 END
13300 C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
13400 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
13500 C P9=NUM IN BRACKET(IF NON-ZERO)
13600
13700 C******** JUGGLER ********
13800 CF SUBROUTINE JUGGLE
13900 CF IMPLICIT INTEGER(A-Z)
14000 CF REAL PWDS,RN
14100 CF COMMON /DL/X22,SAVER,NAME /XRN/RN(4000)
14200 CF COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
14300
14400 CF ITEM=ITEM-1
14500 CF JX=RN(MEDIT)+3
14600 C WD CNT OF OLD ITEM
14700 C I-IX IS WD CNT OF NEW ITEM
14800 CF JY=IX
14900 CF Z=I-IX-JX
15000 C SPACE CHANGE
15100 CF IF(Z)2751,172,751
15200 CF751 CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
15300 CF JY=IX+Z
15400 CF GO TO 172
15500
15600 CF2751 CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
15700
15800 CF172 J=RN(JY)+2
15900 CF CALL LOOP(0,J,1,MEDIT,JY,RN)
16000 CF I=IX+Z
16100
16200 CF1751 X=ITEM+1
16300 CF JX=WDS(X22+1)-WDS(X22)
16400 CF J=WDS(X+1)-WDS(X)
16500 CF Y=J-JX
16600 CF JX=WDS(X)+Y+1
16700 CF IF(Y)2851,182,282
16800 CF282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
16900 CF GO TO 182
17000
17101 CF2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
17200 CF JX=WDS(X)+1
17300
17401 CF182 CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
17500 CF DO 183 K=X22+1,X
17600 CF PWDS(K)=PWDS(K)+Z
17700 CF183 WDS(K)=WDS(K)+Y
17800 CF ST(2)=WDS(X)
17900 CF X22=0
18000 CF END
18100
18200
18300 CF SUBROUTINE LOOP(I,J,K,L,M,N)
18400 CF DIMENSION N(1)
18420 CF MM=M-L
18500 CF DO 1 NN=I+L,J+L,K
18600 CF1 N(NN)=N(NN+MM)
18700 CF END
19300
19400
19500 SUBROUTINE PLTSRT
19600 C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
19700 CF IMPLICIT INTEGER(S-Z)
19800 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
19940 COMMON/DPY/Q(3000),P(1000),WDS(250),MEDIT,IGO
19970 C Q AND P OCCUPY DPY BUFFER. Q IS FOR OVERFLOW OF RN.
19985 CALL PSRT(P)
20000 CF DO 4 K=1,ITEM
20100 CF L=PWDS(K)
20150 CF A=RN(L+3)
20200 CF P(K)=A+1000*RN(L+2)
20250 CF4 IF(A.LT.0)GO TO 77
20262 CF IF(RN(L+1).NE.16.)GO TO 177
20268 CF77CF P(K)=-10000
20275 C PLOTS ALL NEG. HORIZ. POSITIONS AND WORDS(CODE 16) FIRST.
20300 CF177CF M=I
20320 CF IF(I.LT.1500)I=1500
20340 CF Y=I
20360 CF I=I+M-1
20380 CF M=Y
20400 C M IS IN MAIN PROG., LEAVES 1500 WDS IN RN FOR "NOIR" DATA.
20500 CF2CF A=P(1)
20600 CF L=1
20700 CF DO 1 K=1,ITEM
20800 CF IF(A.LE.P(K))GO TO 1
20900 CF A=P(K)
21000 CF L=K
21100 CF1CF CONTINUE
21200 CF IF(A.EQ.10000.)RETURN
21300 C ALL ITEMS HAVE NOW BEEN SHUFFLED
21400 CF V=PWDS(L)
21500 CF P(L)=10000
21600 CF L=RN(V)+2
21700 CF CALL LOOP(0,L,1,Y,V,RN)
21800 CF Y=Y+L+1
21900 CF GO TO 2
22000 END
22100
22200
22300
22400 SUBROUTINE BOX(I,R,STFF)
22500 COMMON/SIZ/RSZ,JCEN,KCEN /XRN/RN(4000) /STF/RSTFAC(-3/4),RSJ/C/L,K
22925 DIMENSION STFF(1),N(100)
22962 EQUIVALENCE (N,RN(2901))
23000 IF(I)GO TO 4
23100 K=R
23200 K=(STFF(K+4)+AMOD(RN(I+4),100.0)*7.*RSTFAC(K)
23300 1 -40.0)*RSZ-KCEN
23350 C ↑↑↑↑ WAS -60.0 10/74
23400 C AMOD IS FOR MINI NOTES AND CLEFS
23500 L=RHORZ(RN(I+3))*RSZ-JCEN
23600 IF(IABS(L).GT.550)L=511
23700 IF(IABS(K).GT.550)K=511
23800 CC1 CALL ALINE(L,K,L+50,K)
23900 CC CALL RVECT(0,100)
24000 CC CALL RVECT(-50,0)
24100 CC CALL RVECT(0,-100)
24200 CC L=L+25
24300 CC2 CALL ALINE(L,K-25,L,K+125)
24450 CC3 CALL DPYOUT(1)
24460 CALL SETCUR(L,K,0)
24500 RETURN
24600 4 IF(I.LT.-1)GO TO 5
24700 CALL DPYSET(3,N,100)
24800 CALL DPYBRT(3)
24900 5 L=RHORZ(R)*RSZ-JCEN
25000 IF(IABS(L).GT.550)GO TO 6
25050 C DOESN'T TRY TO DRAW LINE OFF SCREEN
25100 CALL SETPOG(3)
25200 CALL ALINE(L,-511,L,511)
25300 CALL DPYOUT(3)
25400 6 CALL SETPOG(1)
25600 END
25700
25800 CC SUBROUTINE LINES(A,B,L)
25850 CC COMMON/DST/BB,CC
25900 CC COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
26000 CC COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
26100 CC COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)
26200 CC COMMON/DPY/JJ(4000),WDS(250),MEDIT,IGO
26400 CC EQUIVALENCE (ITOP,JJ(3999)),(IBOT,JJ(4000))
26402 CC 1,(JJ2,JJ(2))
26500 CC DATA BB/.008/,CC/3.5/
26600 C SET XGP TO 1200.0 FOR MARGIN IN XEROX COPIES
26650 CC GO TO 23
26700 CC
26725 CC22 IF(JQ(1).NE.0)GO TO 23
26750 CC IF(CC.EQ.1000)GO TO 23
26775 C ABOVE TO SKIP DISTORTION ON COMMAND
26800 C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
27000 C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
27100 CC B=B*(CC-BB*ABS(A))
27150 C CC IS HGT FACTOR.
27200 CC23 IF(IPLT)GO TO 2
27300 CC M=A*RSZ
27400 CC N=B*RSZ
27500 CC IF(RSZ.LE.0.8571)GO TO 3
27600 C NEXT FOR DISPLAY MAGNIFICATION
27700 CC M=M-JCEN
27800 CC N=N-KCEN
27900 CC IF(JA.NE.8)GO TO 5
28000 C NEXT INSURES DISPLAY OF STAFF LINES
28100 CC IF(M.GT.511)M=511
28200 CC IF(M.LT.-511)M=-511
28400 CC5 IF(IABS(M).GT.512)GO TO 77
28450 CC IF(IABS(N).LT.512)GO TO 4
28500 C NOW DRAWS INVISIBLE VECT. IF IT GOES OFF THE SCREEN.
28600 CC77 KZ=-1
28700 CC RETURN
28800 CC4 IF(KZ.EQ.0)GO TO 6
28900 CC KZ=0
29000 CC GO TO 1
29050 CC3 IF(JA.EQ.44)GO TO 6
29075 C JA=44=BAR LINES - THEY DON'T FIGURE IN MAX. HGT.
29100 CC K=B
29200 CC IF(K.GT.ITOP)ITOP=B
29300 CC IF(K.LT.IBOT)IBOT=B
29302 CC6 IF(JJ2.GT.3990)RETURN
29400 CC IF(L.EQ.3)GO TO 1
29500 CC CALL AVECT(M,N)
29600 CC RETURN
29700 CC1 CALL AIVECT(M,N)
29800 CC RETURN
29900 CC2 IF(IPLT.EQ.-2)RETURN
30300 C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
31110 CC9 M=ROFF(A*DIS)
31120 CC N=ROFF(B*RHT)
31200 CC8 CALL PLOT(M,N,L)
31400 CC END
31540
35100 C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
35200 CF SUBROUTINE HOMER
35300 CF IMPLICIT INTEGER(A-Q,S-Z)
35400 CF REAL PWDS,DISX,A,B,PLACE,STFF
35500 CF COMMON /STF/RSTFAC(-3/4),RSTJ2
35600 CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(-3/4),JJ2,POS
35700 CF COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
35800 CF COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
35900 CF EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9)),(RD,RN(4000))
36000 CF 1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
36100 CF 1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5))
36200 CF IF(JA.EQ.6)GO TO 9
36300 CF IF(R13.NE.0)GO TO 10
36400 C FOR GENL HOMING; WORDS; BEAMS; STEMS;
36500
36600 CF IF(JQ(1).EQ.0)GO TO 197
36700 C TO HOME IN ON NOTE ON DIFFERENT STAFF.
36800 CF JJ2=R2
36900 CF K=PWDS(JJ2)
37000 CF L=PWDS(JQ(1))
37100 CF RA=RN(K+3)
37200 CF RB=RN(L+3)
37300 C RB=POS OF NOTE, RA=POS(P3) OF BEAM
37400 CF N=0
37500 CF IF(RN(L+5).LT.20)N=-1
37600 C -1 MEANS STEM IS UP
37700 CF RG=-(AMOD(RN(K+7),10.)-1.)*11./7.
37800 C SPACE FOR THE NUMB. OF BEAMS
37900 CF J11=RN(L+2)
38000 CF M=0
38100 CF IF(RN(K+7).LT.20.)M=-1
38200 CF X=RN(K+2)
38300 C THE STAFF NUMS. X=BEAM J11=NOTE
38400 CF R3=RSTFAC(X)
38500 CF R9=RSTFAC(J11)/R3
38600 CF R8=R3*14.54/5.96
38700 C R8=WIDTH OF NOTE
38800 C******* 5/74 BOTH STAVES MUST BE SAME SIZE - MOST LIKELY ********
38900 CF R7=96./7.
39000 C MUST BE DOUBLE STEM LENGTH
39100 CF RD=RN(L+8)
39200 CCCF IF(RD.EQ.999)RD=0
39300 C THE STEM LENGTH
39900 CF3 IF(M.NE.N)GO TO 5
40000 CF R8=0
40100 CF R7=0
40200 CF RG=0
40300 CF GO TO 4
40400 CF5 IF(M.EQ.0)GO TO 4
40500 CF R7=-R7
40600 CF R8=-R8
40700 CF RD=-RD
40800 CF RG=-RG
40900
41000 C NOT OK IF DIFF SIZES AND RA.GT.RB ****** 5/74
41100 CF4 RN(K+6)=RB+R8
41200 C SETS CORRECT HORIZANTAL PARAM OF BEAM.
41300 CF RF=7.*R9
41400 CF RE=(STFF(J11)-STFF(X))/RF
41500 C DIST BETWEEN STAVES.
41600 CF RN(K+5)=RN(L+4)+RE+(R7+RD+RG)*R9
41700 CF RETURN
41800
41900 C*********************************************************
42000 C NEXT ADJUSTS STEMS WHEN BEAMS ARE USED.
42100 CF197 JJ2=-1
42200
42300 CF R3=R2
42400 CF DO 191 K=1,ITEM
42500 CF L=PWDS(K)
42600 CF IF(RN(L+1).NE.6)GO TO 191
42650 CF IF(RN(L+2).EQ.R3)GO TO 77
42675 CF IF(R3.LT.5.)GO TO 191
42700 C TYPE 19 99 FOR ALL STAVES
42800 CF77 RG=RN(L+7)
42900 CF IF(RN(L).EQ.8)GO TO 191
42950 CF IF(RG.LT.10.)GO TO 191
43000 C FINDS BEAMS.
43100 CF A=RN(L+3)-.01
43200 CF B=RN(L+6)+.01
43300 C POS 1 AND 2
43400 CF DISX=B-A
43500 C DISTANCE IN REAL STEPS
43600 CF RB=AMOD(RN(L+5),100.0)
43700 C NOTE 2
43800 CF RF=AMOD(RN(L+4),100.0)
43900 CF RD=RB-RF
44000 C HEIGHT
44100 CF R2=RN(L+2)
44200 C ↑↑↑ USED IN 'FINDIT'
44300 CF X=RG/10.
44400 C STEM DIRECT.
44500
44600 CF DO 192CF N=1,ITEM
44800 CF IF(FINDIT(N))GO TO 192
44900 CF IF(RN(L).EQ.8)GO TO 192
44950 CF IF(RN(L+8).EQ.1000.)GO TO 192
45000 C SKIPS SLASHED GRACE NOTES (P8=1000 OR P10=1)
45100 C FINDIT IS NEG. IF(RN(L+1).NE.1.OR.RN(L+3))
45200 CF RC=RN(L+3)
45300 CF IF(RC.LT.A)GO TO 192
45350 CF IF(RC.GT.B)GO TO 192
45400 C WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
45500 CF IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
45600 CF RC=RC-A
45700 CF193 RE=AMOD(RN(L+4),100.0)
45800 CF RC=RD*RC/DISX+RF
45900 CF RG=RN(L+7)
46000 CF RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
46100 C DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
46200 C FRACTIONAL NOTE #
46300 CF195 RA=RC-RE
46400 CF IF(X.EQ.2)RA=-RA
46500 CF IF(RA.EQ.0)RA=999.
46600 CF196 RN(L+8)=RA
46700 C FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
46800 CF IF(JJ2)JJ2=N
46900 C SAVES # OF FIRST ITEM FOUND
47000 CF192 CONTINUE
47100 CF191 CONTINUE
47200 CF RETURN
47300
47400 C*********************************************************
47500 CF9 IF(J11.LT.0)RETURN
47600 C IF P11=-1 NO HOMING
47700 CF X=R7/10.
47750 CF IF(X)X=-X
47800 C X IS STEM DIRECTION
47900 CF RA=R9
48000 C R9= POS3
48100 CF RC=-1.
48200 CF IF(R9.NE.0)RC=-2.
48300 CF IF(J10/10.EQ.3)RC=-3
48400 C RC=1 ESCAPES FROM LOOP.
48500 C HOMING RANGE FOR BEAMS
48600 CF10 IF(R11.EQ.0)R11=2.9
48700 C IF P11.NE.0 RANGE IS CHANGED FROM 2
48800 CF IF(JA.EQ.5)RC=-1
48850 C******↑↑↑↑↑↑↑ WAS 8????
48900 CF DO 361 K=1,ITEM
49000 CF IF(FINDIT(K))GO TO 361
49100 C SKIPS NOTES ON WRONG LINE
49200 CF RD=RN(L+3)
49300 CF1 IF(JA.NE.6)GO TO 177
49350 CF IF(IFIX(RN(L+5)/10).NE.X)GO TO 361
49400 CF177 IF(PLACE(R3))GO TO 461
49500 CF R3=RD
49600 C LOOKS FOR NOTE, STAFF #, STEM DIR.
49700 CF IF(JA.EQ.6)GO TO 861
49750 CF IF(JA.EQ.5)GO TO 261
49800 CF RETURN
49900
50000 CF461 IF(JA.EQ.6)GO TO 277
50050 CF IF(JA.NE.5)GO TO 361
50100 CF277 IF(PLACE(R6))GO TO 561
50200 CF R6=RD
50350 CF861 IF(J7.GE.0)GO TO 261
50400 CF561 IF(PLACE(RA))GO TO 661
50450 CF IF(J7)GO TO 761
50462 C J7=NEG MEANS TREMOLO
50475 CF IF(R8.EQ.0)GO TO 361
50500 CF761 R9=RD
50550 C R8=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM.
50600 CF GO TO 261
50700 CF661 IF(JA.EQ.5)GO TO 361
50750 CF IF(J10.LT.30)GO TO 361
50800 CF IF(PLACE(R8))GO TO 361
50900 C HOMES INNER PARTIAL BEAMS
51000 CF R8=RD
51100 CF261 RC=RC+1
51200 CF IF(RC.EQ.1.)RETURN
51300 CF361 CONTINUE
51400 CF END
51500
51600 CF FUNCTION PLACE(X)
51700 CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
51800 CF EQUIVALENCE (R11,RJQ(9)),(RD,RN(4000))
51900 CF PLACE=R11-ABS(RD-X)
52000 CF END
52100
52200 CF FUNCTION FINDIT(N)
52300 CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
52400 CF COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
52500 CF FINDIT=0
52600 CF L=PWDS(N)
52700 CF IF(RN(L+1).NE.1)GO TO 377
52750 CF IF(RN(L+2).EQ.R2)RETURN
52775 CF377 FINDIT=-1
52800 CF END
52900
53000 SUBROUTINE SCL
53100 C SETS UP SCALING MARKERS.
53200 DIMENSION SU(400)
53300 COMMON /STF/RSTFAC(-3/4),RSTJ2 /XRN/RN(4000)
53400 COMMON R2,JA,CT,J2,R3,R4,R5,RJQ(17),J3,J4,J5,J6,J(16)
53500 1 /POSI/STFF(-3/4),J102,POS
53600 EQUIVALENCE (SU(400),RN(3001))
53700 J2=R2
53800 IF(J2.NE.99)GO TO 1008
53900 CALL HYDPOG(2)
54000 RETURN
54100 1008 J5=0
54200 J6=0
54300 RSTJ2=RSTFAC(J2)
54400 C SETS UP SCALE LINES.
54500 J4=200
54600 IF(R3.NE.0)J4=400
54700 C PUTS SCALE TO 400
54800 R2=STFF(J2)+60.*RSTJ2
54900 RJ=R2+60.
55000 CALL DPYSET(2,SU,700)
55100 CALL DPYBRT(1)
55200 POS=RJ+40.
55300 RSTJ2=1.
55400 DO 1002 MX=10,J4,10
55500 RA=RHORZ(FLOAT(MX))
55600 R3=RA-58
55700 IF(MX.GT.10)CALL PNUM
55800 CC1005 IF(R5.NE.0)GO TO 1007
55900 C JUMP FOR STAFF NUMBERS
56000 CALL LINX(RA,R2,RA,RJ)
56100 J5=J5+1
56200 1002 IF(J5.EQ.10)J5=0
56300 CALL LINES(-596.0,RJ,2)
56400 CALL LINES(-596.0,R2,2)
56500 R6=1.5
56600 C NEXT SETS UP STAFF NUMBERS
56700 R3=-620.
56800 DO 1007 K=-3,4
56900 POS=STFF(K)+40.
57000 J5=IABS(K)
57100 CALL PNUM
57200 1007 CONTINUE
57300 CALL DPYOUT(2)
57400 CALL SETPOG(1)
57450 END
57475
57500 C NEXT ALLOWS YOU TO TYPE 'SA NAME' OR 'SAVE NAME' ETC.
57600 C (NO MORE THAN 9 CHARS. MAY COME BEFORE NAME)
57700 SUBROUTINE FORMAT(NAME)
57750 C SO WE CAN TYPE 'SA NAME' OR 'SAVE NAME', ETC.
57800 COMMON /ALF/INP(72),ML
57900 DIMENSION DMY(50),IFMT(2)
58000 EQUIVALENCE (INP(20),DMY)
58100 DATA IFMT(2)/' ,A5)'/
58200
58300 DO 1 K=2,72
58400 IF(INP(K).NE.' ')GO TO 1
58500 DO 2 L=K+1,72
58600 IF(INP(L).EQ.' ')GO TO 2
58700 C NOW WE START NAME
58800 L=L-1
58900 5 IFMT(1)='( 0A1'+L*32768
59000 C 32768 IS MAGIC NUM TO CHANGE '0' TO RIGHT NUM.
59100 REREAD IFMT,(DMY(K),K=1,L),NAME
59200 RETURN
59300 2 CONTINUE
59400 NAME=' '
59500 RETURN
59600 1 CONTINUE
59700 END